home *** CD-ROM | disk | FTP | other *** search
/ The Original Shareware 1.1 / The Original Shareware (WeMake CDs)(Volume 1.1)(CDs, Inc)(1993).iso / 18 / fpc103.zip / DEBUG.SEQ < prev    next >
Text File  |  1988-06-10  |  7KB  |  204 lines
  1. \ DEBUG.SEQ     A high level debugger      Enhancements by Tom Zimmer
  2.  
  3. \ The debugger is designed to let the user single step the
  4. \ execution of a high level definition.  To invoke the
  5. \ debugger, type DEBUG XXX where XXX is the name of the
  6. \ word you wish to trace.  When XXX executes, you will get
  7. \ a single step trace showing you the word within XXX that
  8. \ is about to execute, and the contents of the parameter
  9. \ stack. This debugger works by patching the NEXT routine,
  10. \ so it is highly machine and implementation dependent.
  11.  
  12. ONLY FORTH ALSO DEFINITIONS
  13.  
  14. VARIABLE DBSEG
  15. VARIABLE 'DEBUG   ( Code field for high level trace )
  16. VARIABLE CNT      ( How many times thru debug next )
  17. DEFER DBG.S     ' .S IS DBG.S   \ default DBG.S to the systems .S
  18.  
  19. HEX
  20.  
  21. LABEL FNEXT   ( Fix the >NEXT code back to normal )
  22.         MOV AX, # AD26          \ ES: LODSW
  23.         MOV >NEXT AX
  24.         MOV AX, # E0FF          \ JMP AX
  25.         MOV >NEXT 2+ AX
  26.         RET END-CODE
  27.  
  28. LABEL DNEXT   ( The Debugger version of a normal >NEXT )
  29.     ES: LODSW JMP AX
  30.         END-CODE
  31.  
  32. DECIMAL
  33.  
  34. HEX LABEL DEBNEXT
  35.         MOV AX, ES
  36.         CMP AX, DBSEG
  37.         0= IF   MOV AX, CNT
  38.                 INC AX
  39.                 MOV CNT AX
  40.                 CMP AX, # 2
  41.                 0= IF   SUB AX, AX
  42.                         MOV CNT AX
  43.                         CALL FNEXT
  44.                         PUSH IP
  45.                         MOV AX, 'DEBUG
  46.                         JMP AX
  47.                 THEN
  48.         THEN    JMP DNEXT
  49.         END-CODE
  50.  
  51. CODE PNEXT   ( -- )
  52.         MOV AL, # 0E9
  53.         MOV >NEXT AL
  54.         MOV AX, # DEBNEXT  >NEXT 3 + -
  55.         MOV >NEXT 1+ AX
  56.         NEXT   C;
  57.  
  58. FORTH DEFINITIONS
  59.  
  60. CODE UNBUG    ( -- )
  61.         CALL FNEXT
  62.         NEXT   C;   DECIMAL
  63.  
  64. BUG ALSO DEFINITIONS
  65.  
  66. CREATE DSTK 100 ALLOT DSTK 100 ERASE
  67.  
  68. VARIABLE SLOWLY   VARIABLE DCNT
  69. VARIABLE SFLG
  70.  
  71. ' >NAME.ID @REL>ABS CONSTANT 'DOCOL
  72. ' KEY      @REL>ABS CONSTANT 'UDEFER
  73. ' BDOS     @REL>ABS CONSTANT 'DEFER
  74.  
  75. : D.ID          ( -- )                      \ DEBUGGER ID DOT
  76.                 CCR DBSEG  @ DUP 6 U.R
  77.                     PFASAV @ DUP 3 U.R @L
  78.                 DUP @REL>ABS DUP 'DOCOL =
  79.                 OVER 'UDEFER = OR SWAP 'DEFER = OR
  80.                 SFLG @ IF DUP 0= SLOWLY ! THEN
  81.                 >R DCNT @ 0 MAX 2/ 16 MOD SPACES R>
  82.                 IF   DUP @REL>ABS 'DOCOL =
  83.                      IF ."  :  " ELSE DUP @REL>ABS 'UDEFER =
  84.                         IF  ."  Ud " ELSE ."  d  " THEN THEN
  85.                 ELSE 4 SPACES   THEN
  86.                 16 SWAP >NAME.ID  NLEN @ - SPACES ;
  87.  
  88. : (DBG)         ( BEGIN_OF_LIST_RELATIVE -- )
  89.                 XSEG @ + DBSEG !
  90.                 SFLG OFF SLOWLY OFF 1 CNT ! ;
  91.  
  92. : DSTK0 DSTK 100 ERASE DCNT OFF ;
  93.  
  94. : >DS   DCNT @ DSTK + !  2 DCNT +! ;
  95.  
  96. : DS>   DCNT @ 2 < 0= IF -2 DCNT +! THEN DCNT @ DSTK + @ ;
  97.  
  98. : >DSTK ( A1-)  DBSEG @ PFASAV @ @L DUP @REL>ABS 'DOCOL =
  99.         IF      ."  Nesting "  DBSEG @ >DS
  100.                 DEFCFA @ >DS DUP DEFCFA !
  101.                 >BODY @ (DBG) EXIT
  102.         THEN    DUP @REL>ABS 'UDEFER =
  103.                 OVER >BODY @ UP @ + @ @REL>ABS 'DOCOL = AND
  104.         IF      ."  UDefering to " DBSEG @ >DS
  105.                 >BODY @ UP @ + @
  106.                 DEFCFA @ >DS DUP DEFCFA !
  107.                 DUP >NAME.ID >BODY @ (DBG) EXIT
  108.         THEN    DUP @REL>ABS 'DEFER =
  109.                 OVER >BODY @ @REL>ABS 'DOCOL = AND
  110.         IF      ."  Defering to "  DBSEG @ >DS
  111.                 >BODY @
  112.                 DEFCFA @ >DS DUP DEFCFA !
  113.                 DUP >NAME.ID >BODY @ (DBG) EXIT
  114.         THEN    DROP ."  Can't, NOT a : def " ;
  115.  
  116. : ?DST>         ( A1- F1 )
  117.                 DBSEG @ PFASAV @ @L ['] UNNEST =
  118.                 DCNT @ 2 > AND
  119.                 IF      DS> DEFCFA ! DS> XSEG @ - (DBG) THEN    ;
  120.  
  121.  
  122. \ Type "?" while in the debugger to display the following line;
  123.  
  124. \       C-cont, F-forth, Q-quit, N-nest, U-unnest, Z-zip:
  125.  
  126. \ The commands are available while debugging, as follows;
  127.  
  128. \       C-cont          Continuous, scrolls through words as they
  129. \                       are executed, stop by pressing <return>.
  130. \       F-forth         Allow entry of Forth commands, until a <return>
  131. \                       is pressed on an empty command line.
  132. \                       P.S. don't make any typing errors or you will
  133. \                       fall out of the debugger.
  134. \       Q-quit          Quit the debugger, and unpatch the debug word.
  135. \                       Returns to Forth.
  136. \       N-nest          Nest into the current definition the debugger
  137. \                       is sitting on, if it is a ":" definition, else
  138. \                       issue an error message but don't abort.
  139. \       U-unnest        Unnest from the current word being debugged, the
  140. \                       debugger will re-enter when the word finishes
  141. \                       executing, and pops up one level to the word that
  142. \                       called it. You cannot Unnest without Nesting.
  143. \       Z-zip           Zip through definitions, like C-cont, but only
  144. \                       zips through code definitions, still pauses on
  145. \                       ":" definitions.
  146.  
  147. : GET-COMMAND   ( --- c1 )
  148.                 BEGIN   ." ?> " .DEFSRC
  149.                         (KEY)   UPC 0 ASCII ? 2 PICK =
  150.                         IF      CCR
  151.                         ." C-cont, F-forth, Q-quit, N-nest, U-unnest, Z-zip:"
  152.                                 0=
  153.                         THEN    ASCII F 2 PICK =
  154.                         IF      >R >R
  155.                                 BEGIN   CCR DBG.S ." ->"
  156.                                         QUERY #TIB @
  157.                                 WHILE   RUN
  158.                                 REPEAT  R> R> 0=
  159.                         THEN
  160.                 WHILE  DROP D.ID REPEAT ;
  161.  
  162. : TRACE   ( Ip - )
  163.         ?CS: TYPESEG DUP @ >R !
  164.         PFASAV ! DBG.S D.ID ?DST> SLOWLY @ 0= (KEY?) OR
  165.         IF      SLOWLY OFF GET-COMMAND
  166.                 ASCII C OVER = IF SFLG OFF SLOWLY ON THEN
  167.                 ASCII Z OVER = IF SFLG @ 0= SFLG ! THEN
  168.                 ASCII N OVER = IF   >DSTK THEN
  169.                 ASCII X OVER = IF   ['] NOOP IS .DEFSRC  ['] CRLF IS CCR
  170.                                THEN
  171.                 ASCII U OVER = IF DCNT @ 2 >
  172.                                   IF DS> DEFCFA ! DS> XSEG @ - (DBG)
  173.                                   ELSE  DROP EXIT THEN
  174.                                THEN
  175.                 ASCII Q OVER = ABORT" Unbug" DROP
  176.         ELSE    3 SPACES
  177.         THEN
  178.         R> TYPESEG !
  179.         PNEXT ;
  180.  
  181. ' TRACE 'DEBUG !
  182.  
  183. FORTH DEFINITIONS
  184.  
  185. : ADEBUG        ( A1 --- ) DUP DEFCFA !
  186.                 DSTK0   DUP @REL>ABS 'DOCOL =
  187.                 IF      [ BUG ] >BODY @ (DBG) PNEXT  EXIT
  188.                 THEN    DUP @REL>ABS 'UDEFER =
  189.                         OVER >BODY @ UP @ + @
  190.                         @REL>ABS 'DOCOL = AND
  191.                 IF      >BODY @ UP @ + @ DUP >NAME.ID
  192.                         >BODY @ (DBG) PNEXT EXIT
  193.                 THEN    DUP @REL>ABS 'DEFER =
  194.                         OVER @ @REL>ABS 'DOCOL = AND
  195.                 IF      >BODY @ DUP >NAME.ID
  196.                         >BODY @ (DBG) PNEXT EXIT
  197.                 THEN    ABORT" Can't, NOT a : def " ;
  198.  
  199. : DEBUG         ' ADEBUG ;
  200. \ : #DEBUG        >R DEBUG R> ABS NEGATE CNT ! ;
  201. \ : DEBUG>        R@ @ ADEBUG ;
  202. : DBG           >IN @  DEBUG  >IN !  ;
  203.  
  204.